home *** CD-ROM | disk | FTP | other *** search
/ X User Tools / X User Tools (O'Reilly and Associates)(1994).ISO / sun4c / archive / tcltk.z / tcltk / slib / tk / demos / mkArrow.tcl < prev    next >
Text File  |  1994-09-20  |  7KB  |  204 lines
  1. # mkArrow w
  2. #
  3. # Create a top-level window containing a canvas demonstration that
  4. # allows the user to experiment with arrow shapes.
  5. #
  6. # Arguments:
  7. #    w -    Name to use for new top-level window.
  8.  
  9. # This file implements a canvas widget that displays a large line with
  10. # an arrowhead and allows the shape of the arrowhead to be edited
  11. # interactively.  The only procedure that should be invoked from outside
  12. # the file is the first one, which creates the canvas.
  13.  
  14. proc mkArrow {{w .arrow}} {
  15.     global tk_library
  16.     upvar #0 demo_arrowInfo v
  17.     catch {destroy $w}
  18.     toplevel $w
  19.     dpos $w
  20.     wm title $w "Arrowhead Editor Demonstration"
  21.     wm iconname $w "Arrow"
  22.     set c $w.c
  23.  
  24.     frame $w.frame1 -relief raised -bd 2
  25.     canvas $c -width 500 -height 350 -relief raised
  26.     button $w.ok -text "OK" -command "destroy $w"
  27.     pack $w.frame1 -side top -fill both
  28.     pack $w.ok -side bottom -pady 5
  29.     pack $c -expand yes -fill both
  30.     message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
  31.         -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases.  To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow.  The arrows on the right give examples at normal scale.  The text at the bottom shows the configuration options as you'd enter them for a line."
  32.     pack $w.frame1.m
  33.  
  34.     set v(a) 8
  35.     set v(b) 10
  36.     set v(c) 3
  37.     set v(width) 2
  38.     set v(motionProc) arrowMoveNull
  39.     set v(x1) 40
  40.     set v(x2) 350
  41.     set v(y) 150
  42.     set v(smallTips) {5 5 2}
  43.     set v(count) 0
  44.     if {[tk colormodel $c] == "color"} {
  45.     set v(bigLineStyle) "-fill SkyBlue1"
  46.     set v(boxStyle) "-fill {} -outline black -width 1"
  47.     set v(activeStyle) "-fill red -outline black -width 1"
  48.     } else {
  49.     set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25"
  50.     set v(boxStyle) "-fill {} -outline black -width 1"
  51.     set v(activeStyle) "-fill black -outline black -width 1"
  52.     }
  53.     arrowSetup $c
  54.     $c bind box <Enter> "$c itemconfigure current $v(activeStyle)"
  55.     $c bind box <Leave> "$c itemconfigure current $v(boxStyle)"
  56.     $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
  57.     $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
  58.     $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3}
  59.     $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
  60.     bind $c <Any-ButtonRelease-1> "arrowSetup $c"
  61. }
  62.  
  63. # The procedure below completely regenerates all the text and graphics
  64. # in the canvas window.  It's called when the canvas is initially created,
  65. # and also whenever any of the parameters of the arrow head are changed
  66. # interactively.  The argument is the name of the canvas widget to be
  67. # regenerated, and also the name of a global variable containing the
  68. # parameters for the display.
  69.  
  70. proc arrowSetup c {
  71.     upvar #0 demo_arrowInfo v
  72.     $c delete all
  73.  
  74.     # Create the arrow and outline.
  75.  
  76.     eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \
  77.         -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \
  78.         -arrow last $v(bigLineStyle)"
  79.     set xtip [expr $v(x2)-10*$v(b)]
  80.     set deltaY [expr 10*$v(c)+5*$v(width)]
  81.     $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \
  82.         [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \
  83.         $v(x2) $v(y) -width 2 -capstyle round -joinstyle round
  84.  
  85.     # Create the boxes for reshaping the line and arrowhead.
  86.  
  87.     eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \
  88.         [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \
  89.         -tags {box1 box}"
  90.     eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \
  91.         [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \
  92.         -tags {box2 box}"
  93.     eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \
  94.         [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \
  95.         -tags {box3 box}"
  96.  
  97.     # Create three arrows in actual size with the same parameters
  98.  
  99.     $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \
  100.         -width 2
  101.     set tmp [expr $v(x2)+100]
  102.     $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \
  103.         -width $v(width) \
  104.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  105.     $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \
  106.         -width $v(width) \
  107.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  108.     $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \
  109.         [expr $v(y)+125] -width $v(width) \
  110.         -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  111.  
  112.     # Create a bunch of other arrows and text items showing the
  113.     # current dimensions.
  114.  
  115.     set tmp [expr $v(x2)+10]
  116.     $c create line $tmp [expr $v(y)-5*$v(width)] \
  117.         $tmp [expr $v(y)-$deltaY] \
  118.         -arrow both -arrowshape $v(smallTips)
  119.     $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \
  120.         -text $v(c) -anchor w
  121.     set tmp [expr $v(x1)-10]
  122.     $c create line $tmp [expr $v(y)-5*$v(width)] \
  123.         $tmp [expr $v(y)+5*$v(width)] \
  124.         -arrow both -arrowshape $v(smallTips)
  125.     $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e
  126.     set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10]
  127.     $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \
  128.         -arrow both -arrowshape $v(smallTips)
  129.     $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \
  130.         -text $v(a) -anchor n
  131.     set tmp [expr $tmp+25]
  132.     $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \
  133.         -arrow both -arrowshape $v(smallTips)
  134.     $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \
  135.         -text $v(b) -anchor n
  136.  
  137.     $c create text $v(x1) 310 -text "-width  $v(width)" \
  138.         -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-*
  139.     $c create text $v(x1) 330 -text "-arrowshape  {$v(a)  $v(b)  $v(c)}" \
  140.         -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-*
  141.  
  142.     incr v(count)
  143. }
  144.  
  145. # The procedures below are called in response to mouse motion for one
  146. # of the three items used to change the line width and arrowhead shape.
  147. # Each procedure updates one or more of the controlling parameters
  148. # for the line and arrowhead, and recreates the display if that is
  149. # needed.  The arguments are the name of the canvas widget, and the
  150. # x and y positions of the mouse within the widget.
  151.  
  152. proc arrowMove1 {c x y} {
  153.     upvar #0 demo_arrowInfo v
  154.     set newA [expr ($v(x2)+5-[$c canvasx $x])/10]
  155.     if {$newA < 1} {
  156.     set newA 1
  157.     }
  158.     if {$newA > 25} {
  159.     set newA 25
  160.     }
  161.     if {$newA != $v(a)} {
  162.     $c move box1 [expr 10*($v(a)-$newA)] 0
  163.     set v(a) $newA
  164.     }
  165. }
  166.  
  167. proc arrowMove2 {c x y} {
  168.     upvar #0 demo_arrowInfo v
  169.     set newB [expr ($v(x2)+5-[$c canvasx $x])/10]
  170.     if {$newB < 1} {
  171.     set newB 1
  172.     }
  173.     if {$newB > 25} {
  174.     set newB 25
  175.     }
  176.     set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10]
  177.     if {$newC < 1} {
  178.     set newC 1
  179.     }
  180.     if {$newC > 20} {
  181.     set newC 20
  182.     }
  183.     if {($newB != $v(b)) || ($newC != $v(c))} {
  184.     $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)]
  185.     set v(b) $newB
  186.     set v(c) $newC
  187.     }
  188. }
  189.  
  190. proc arrowMove3 {c x y} {
  191.     upvar #0 demo_arrowInfo v
  192.     set newWidth [expr ($v(y)+5-[$c canvasy $y])/5]
  193.     if {$newWidth < 1} {
  194.     set newWidth 1
  195.     }
  196.     if {$newWidth > 20} {
  197.     set newWidth 20
  198.     }
  199.     if {$newWidth != $v(width)} {
  200.     $c move box3 0 [expr 5*($v(width)-$newWidth)]
  201.     set v(width) $newWidth
  202.     }
  203. }
  204.